home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
User's Choice Windows CD
/
User's Choice Windows CD (CMS Software)(1993).iso
/
win_a_d
/
co39.zip
/
FILECOPY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-08-10
|
13KB
|
471 lines
{**** FileCopy Copyright 1992 Doug Overmyer ********}
unit filecopy;
{$R filecopy.RES}
{$I+}
interface
uses WinTypes, WinProcs, WObjects,Strings,windos,commdlg,win31,
sclptext,Meter;
const
FC_Name = 'FileCopy';
id_StH = 101;
id_STJ = 102;
id_Copy = 201;
id_Move = 202;
id_About = 501;
id_CMFrom = 601;
id_CMTo = 602;
id_CMCopy = 603;
id_CMMove = 604;
id_CMDel = 605;
id_CMExit = 610;
{********************** TYPES ******************************}
type
PFCWindow = ^TFCWindow;
TFCWindow = object(TWindow)
Files:PStrCollection;
StH,StJ:PSText;
SourceBuf:PChar;
SourceDir,TargetDir:PChar;
IsActive:Boolean;
constructor Init(AParent:PWindowsObject;ATitle: PChar);
function GetClassName:PChar;virtual;
destructor Done; virtual;
procedure SetupWindow;virtual;
procedure CMFrom(Var Msg:TMessage);virtual cm_First+id_CMFrom;
procedure CMTo(var Msg:TMessage);virtual cm_First+id_CMTo;
procedure CMCopy(Var Msg:TMessage);virtual cm_First+id_CMCopy;
procedure CMMove(Var Msg:TMessage);virtual cm_First+id_CMMove;
procedure CMDel(var Msg:TMessage);virtual cm_First+id_CMDel;
procedure CMExxit(Var Msg:TMessage);virtual cm_First+id_CMExit;
procedure CopyMove(ActionType:Integer);
procedure SetHeader(Msg:Pchar);
procedure WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
function CanClose:Boolean;virtual;
procedure CleanUp;virtual;
end;
{*****************************************************************}
implementation
{********************* Functions *******************************}
function StrTok(P:PChar;C:Char):PChar;
const
Next:Pchar = nil;
begin
if P = NIL then P := Next;
if P <> NIL then
begin
Next := StrScan(P,C);
If Next <> NIL then
begin
Next^ := #0;
Next := Next+1;
end;
end;
StrTok := P;
end;
procedure Take5;
var MsgP:TMsg;
begin
while PeekMessage(MsgP,0,0,0,PM_REMOVE) do
begin
if MsgP.Message = WM_QUIT then
begin
Application^.Done;
Halt;
end;
TranslateMessage(MsgP);
DispatchMessage(MsgP);
end
end;
{********************** METHODS ******************************}
{********************** TFCWindow *******************************}
constructor TFCWindow.Init(AParent:PWindowsObject;ATitle: PChar);
var
Indx:Integer;
begin
TWindow.Init(nil, ATitle);
with Attr do
begin
X := 50; Y := 50; W := 340; H := 100;
DisableAutoCreate;
Attr.Style := ws_Popup or ws_Visible or ws_Border or ws_Caption
or ws_MinimizeBox or ws_SysMenu;
Menu := LoadMenu(hInstance,'FC_Menu');
end;
StJ := New(PSText,Init(@Self,id_StH,'',30,30,275,20,sr_Recessed,
dt_Left or dt_VCenter or dt_SingleLine));
StH := New(PSText,Init(@Self,id_StJ,'',30,5,275,20,sr_Recessed,
dt_Left or dt_VCenter or dt_SingleLine));
GetMem(SourceBuf,4096);
GetMem(SourceDir,fsDirectory+1);
GetMem(TargetDir,fsDirectory+1);
StrCopy(SourceBuf,'');
StrCopy(SourceDir,'');
Strcopy(TargetDir,'');
Files := New(PStrCollection,Init(10,10));
IsActive := False;
end;
function TFCWindow.GetClassName:PChar;
begin
GetClassName := 'FCWindow';
end;
destructor TFCWindow.Done;
begin
FreeMem(SourceBuf,4096);
FreeMem(SourceDir,fsDirectory+1);
FreeMem(TargetDir,fsDirectory+1);
Dispose(Files,Done);
TWindow.Done;
end;
procedure TFCWindow.SetupWindow;
var
SysMenu:HMenu;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'FC_Icon'));
SetClassWord(HWindow,GCW_HBrBackground,GetStockObject(ltGray_Brush));
Sysmenu := GetSystemMenu(hWindow,false);
AppendMenu(SysMenu,MF_Separator,0,nil);
AppendMenu(Sysmenu,0,id_About,'About...');
SetHeader('');
end;
procedure TFCWindow.SetHeader(Msg:PChar);
var
Buf:Array[0..200] of Char;
M:Record
SC:PChar;
cFiles:Integer;
end;
begin
M.SC := SourceDir;
M.cFiles := Files^.Count;
wvsprintf(Buf,'Source:%s Count:%i',M);
StH^.SetText(Buf);
wvsprintf(Buf,'Target:%s',TargetDir);
StJ^.SetText(Buf);
end;
procedure TFCWindow.CMFrom(var Msg:TMessage);
const
szFilter:Array[0..8] of Char ='*.*'#0'*.*'#0#0;
var
szDirName:Array[0..256] of Char;
szFile,szFileTitle:Array[0..512] of Char;
OFN:TOpenFileName;
P:PChar;
OldDir:Array[0..fsDirectory] of char;
Path,PathName:Array[0..69] of Char;
FName:Array[0..18] of Char;
pResult:PChar;
begin
Files^.FreeAll;
GetCurDir(OldDir,0);
StrCopy(SourceBuf,'');
StrCopy(SourceDir,'');
OFN.lStructSize := sizeof(TOpenFileName);
OFN.hWndOwner := HWindow;
OFN.lpStrFilter := @szFilter;
OFN.lpStrCustomFilter := nil;
OFN.nMaxCustFilter := 0;
OFN.nFilterIndex := LongInt(1);
OFN.lpStrFile := SourceBuf;
OFN.nMaxFile := 4096;
OFN.lpstrfileTitle := szFileTitle;
OFN.nMaxFileTitle := sizeof(szFileTitle);
OFN.lpstrInitialDir := NIL;
OFN.lpStrTitle := 'Source Files';
OFN.flags := OFN_ALLOWMULTISELECT;
OFN.nFileOffset := 0;
OFN.nFileExtension := 0;
OFN.lpstrDefext := nil;
if GetOpenFileName(OFN) then
GetCurDir(SourceDir,0);
if StrLen(SourceBuf) > 0 then
begin
pResult := StrScan(SourceBuf,' ');
if pResult = NIL then {1 file only}
Files^.Insert(StrNew(SourceBuf))
else {2 or more }
begin
pResult := StrTok(SourceBuf,' '); {get the path}
StrCopy(Path,pResult);
SetCurDir(Path); {chdir there}
pResult := StrTok(NIL,' '); {get the 1st filename}
while pResult <> NIL do
begin
FileExpand(PathName,pResult); {expand file name}
Files^.Insert(StrNew(PathName)); {store it in collection}
pResult := StrTok(NIL,' '); {get next file name}
end;
end;
end;
SetHeader('');
{ SetCurDir(OldDir);}
end;
procedure TFCWindow.CMTo(var Msg:TMessage);
const
szFilter:Array[0..8] of Char ='ALL'#0'*.*'#0#0;
var
szDirName,TargetBuf:Array[0..256] of Char;
szFile,szFileTitle:Array[0..512] of Char;
OFN:TOpenFileName;
P:PChar;
OldDir:Array[0..fsDirectory] of char;
begin
GetCurDir(OldDir,0);
StrCopy(TargetBuf,'');
StrCopy(TargetDir,'');
OFN.lStructSize := sizeof(TOpenFileName);
OFN.hWndOwner := HWindow;
OFN.lpStrFilter := @szFilter;
OFN.lpStrCustomFilter := nil;
OFN.nMaxCustFilter := 0;
OFN.nFilterIndex := LongInt(1);
OFN.lpStrFile := TargetBuf;
OFN.nMaxFile := sizeOf(TargetBuf);
OFN.lpstrfileTitle := szFileTitle;
OFN.nMaxFileTitle := sizeof(szFileTitle);
OFN.lpstrInitialDir := NIL;
OFN.lpStrTitle := 'Target Directory';
OFN.flags := OFN_PATHMUSTEXIST OR OFN_NOVALIDATE;
OFN.nFileOffset := 0;
OFN.nFileExtension := 0;
OFN.lpstrDefext := nil;
if GetOpenFileName(OFN) then
GetCurDir(TargetDir,0);
SetHeader('');
SetCurDir(OldDir);
end;
procedure TFCWindow.CMCopy(var Msg:TMessage);
begin
if Files^.Count = 0 then
MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP)
else if StrLen(TargetDir) = 0 then
MessageBox(HWindow,'Please select target first','Now get this...',MB_ICONSTOP)
else if StrIComp(SourceDir,TargetDir) = 0 then
MessageBox(HWindow,'Source & target directories must differ!','Now get this...',MB_ICONSTOP)
else CopyMove(id_Copy);
end;
procedure TFCWindow.CMMove(var Msg:TMessage);
begin
if Files^.Count = 0 then
MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP)
else if StrLen(TargetDir) = 0 then
MessageBox(HWindow,'Please select target first','Now get this...',MB_ICONSTOP)
else if StrIComp(SourceDir,TargetDir) = 0 then
MessageBox(HWindow,'Source & target directories must differ!','Now get this...',MB_ICONSTOP)
else CopyMove(id_Move);
end;
procedure TFCWindow.CopyMove(ActionType:Integer);
const
BufLen:Integer = 16384;
var
Path,Dir,Name,Ext,TPathName:Array[0..69] of Char;
FName:Array[0..18] of Char;
pResult:PChar;
Indx,Error,Dr,MoveCount:Integer;
F1,F2:File;
MsgX:Array[0..50] of Char;
Buffer:PChar;
Count,BytesRead,FileBytes:LongInt;
MsgXRec : Record
CopyCount:Integer;
Action:PChar;
TotBytes:LongInt;
end;
MsgD:TMsg;
Meter:PMeterWindow;
Pct:Integer;
OutBuf:Array[0..80] of Char;
begin
Meter:=New(PMeterWindow,Init(@Self,'Copying Files...'));
Application^.MakeWindow(Meter);
Meter^.Draw(0); Pct := 0;
UpdateWindow(Meter^.HWindow);
IsActive := True;
Buffer :=MemAlloc(BufLen);
MsgXRec.CopyCount := 0;
MsgXRec.TotBytes := 0;
Dr := Ord(UpCase(TargetDir[0]));
for Indx := 0 to (Files^.Count -1) do {copy the selected files}
begin
If (Pct < ((Indx * 100) div Files^.Count)) then
begin
Meter^.Draw(Pct);
Inc(Pct,5);
end;
pResult := Files^.At(Indx);
Assign(F1,PResult);
FileMode := 0;
{$I-}
Reset(F1,1);
{$I+}
if IOResult <> 0 then
begin
Meter^.CloseWindow;
wvsprintf(OutBuf,'Error openining file:%s',pResult);
MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
CleanUp;
FreeMem(Buffer,Buflen);
IsActive := False;
Exit;
end;
FileBytes := FileSize(F1);
if DiskFree(Dr-64) < FileBytes then
begin
Meter^.CloseWindow;
MessageBox(HWindow,'Insufficient Disk Space!','Copy/Move Aborted',MB_ICONSTOP);
CleanUp;
FreeMem(Buffer,Buflen);
IsActive := False;
Exit;
end;
Count := FileBytes;
BytesRead := 0;
FileSplit(PResult,Dir,Name,Ext);
StrCopy(TPathName,TargetDir);
if TPathName[StrLen(TPathName)-1] = '\' then
TPathName[StrLen(TPathName)-1] := #0;
StrCat(StrCat(Strcat(TPathName,'\'),Name),Ext);
Assign(F2,TPathName);
{$I-}
Rewrite(F2,1);
{$I+}
if IOResult <> 0 then
begin
Meter^.CloseWindow;
wvsprintf(OutBuf,'Error creating file:%s',TPathName);
MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
CleanUp;
FreeMem(Buffer,Buflen);
IsActive := False;
Exit;
end;
while Count > 0 do
begin
if Count > BufLen then Count := BufLen;
BlockRead(F1,Buffer^,Count);
BlockWrite(F2,Buffer^,Count);
BytesRead := BytesRead + Count;
Count:= FileBytes - BytesRead;
end ;
Close(F1);
Close(F2);
Inc(MsgXRec.CopyCount);
MsgXRec.TotBytes := FileBytes + MsgXRec.TotBytes;
Take5;
end;
MsgXRec.Action := 'copied';
if ActionType = id_Move then
begin
for Indx := 0 to (Files^.Count -1) do {delete the selected files}
begin
pResult := Files^.At(Indx);
Assign(F1,pResult);
{$I-}
Erase(F1);
{$I+}
if IOResult <> 0 then
begin
Meter^.CloseWindow;
wvsprintf(OutBuf,'Error erasing file:%s',pResult);
MessageBox(HWindow,OutBuf,'Copy/Move Aborted',MB_ICONSTOP);
Cleanup;
FreeMem(Buffer,Buflen);
IsActive := False;
Exit;
end;
Inc(MoveCount);
end;
MsgXRec.Action := 'moved'
end;
Meter^.CloseWindow;
MsgXRec.TotBytes := MsgXRec.TotBytes div 1024;
wvsprintf(MsgX,'%i Files %s / %li KB',MsgXRec);
MessageBox(HWindow,MsgX,'OM File',0);
FreeMem(Buffer,Buflen);
CleanUp;
IsActive := False;
end;
procedure TFCWindow.CMDel(var Msg:TMessage);
var
pResult:PChar;
Indx,Error,DelCount:Integer;
F1:File;
MsgX:Array[0..50] of Char;
OutBuf:Array[0..80] of Char;
oC:HCursor;
begin
DelCount := 0;
if Files^.Count = 0 then
begin
MessageBox(HWindow,'Please select files first','Now get this...',MB_ICONSTOP);
Exit;
end;
oC :=SetCursor(LoadCursor(0,IDC_Wait));
for Indx := 0 to (Files^.Count -1) do {process the selected files}
begin
pResult := Files^.At(Indx);
Assign(F1,pResult);
Assign(F1,pResult);
{$I-}
Erase(F1);
{$I+}
if IOResult <> 0 then
begin
wvsprintf(OutBuf,'Error erasing file:%s',pResult);
MessageBox(HWindow,OutBuf,'Erase Aborted',MB_ICONSTOP);
CleanUp;
IsActive := False;
Exit;
end;
Inc(DelCount);
end;
SetCursor(oC);
wvsprintf(MsgX,'%i Files deleted',DelCount);
MessageBox(HWindow,MsgX,'File Delete',0);
CleanUp;
end;
procedure TFCWindow.CMExxit(var Msg:TMessage);
begin
CloseWindow;
end;
procedure TFCWindow.WMSysCommand(var Msg:TMessage);
begin
case Msg.Wparam of
id_About:
application^.ExecDialog(New(PDialog,Init(@Self,'FC_About')));
else
DefWndProc(Msg);
end;
end;
function TFCWindow.CanClose:Boolean;
begin
if IsActive = True then
CanClose := False
else
CanClose := TWindow.CanClose;
end;
procedure TFCWindow.CleanUp;
begin
Files^.FreeAll;
StrCopy(SourceDir,'');
StrCopy(TargetDir,'');
SetHeader('');
end;
end.